home
***
CD-ROM
|
disk
|
FTP
|
other
***
search
/
Collection of Tools & Utilities
/
Collection of Tools and Utilities.iso
/
pascal
/
svgadc30.zip
/
fontedit.pas
< prev
next >
Wrap
Pascal/Delphi Source File
|
1993-03-03
|
5KB
|
173 lines
program Font_Editor;
{ This allows you to make your own SVGA fonts however you have }
{ to run the program from TP if you start changing the Width and }
{ Height of characters. Click on character you wish to edit. }
{ Use left mouse button to add a pixel, right mouse button to }
{ delete a pixel. 's' to save, 'l' to load CharSetName and }
{ 'q' to quit. }
uses SVGA, Crt;
const MaxNumChars = 95; { Maximum number of Characters }
Width = 7;
Height = 9;
CharSetName = 'standard.chr'; { Name of Character Set file }
{ MAKE SURE THAT WIDTH AND HEIGHT ARE SET FOR THE APPROPRIATE FONT }
{ 'future.chr' Width = 15 Height = 12 not finished }
{ 'standard.chr' Width = 7 Height = 9 }
type CharType = array[ 0..Width, 0..Height ] of boolean;
CharSetType = array[ 0..MaxNumChars ] of CharType;
var GM : GraphicMouse;
CharSet : ^CharSetType;
xx, yy, Btn, Rx, Ry, CutX, CutY : integer;
PresentChar : byte;
ReadCh : Char;
Done : boolean;
procedure DrawChar( Ch : integer );
var i, j : integer;
begin
GM.Show( False );
Rx := (Ch mod 16)*39+6;
Ry := (Ch div 16)*39+246;
Rectangle( Rx, Ry, Rx+27, Ry+27, 252 );
for i := 0 to Width do
for j := 0 to Height do
if CharSet^[Ch][i,j] then
RectFill( i*9+1, j*9+1, i*9+8, j*9+8, 253 )
else
RectFill( i*9+1, j*9+1, i*9+8, j*9+8, 0 );
GM.Show( True );
end;
procedure SetUp;
var i, j, k : integer;
begin
SetMode( SVGA6448 );
LoadPalette( 'pal002.pal' );
for i := 0 to 15 do
for j := 0 to 5 do
begin
Rx := i*39;
Ry := j*39;
Rectangle( Rx , Ry+240, Rx+39, Ry+279, 35 );
Rectangle( Rx+1, Ry+241, Rx+38, Ry+278, 27 );
Rectangle( Rx+2, Ry+242, Rx+37, Ry+277, 21 );
Rectangle( Rx+3, Ry+243, Rx+36, Ry+276, 16 );
Rectangle( Rx+4, Ry+244, Rx+35, Ry+275, 10 );
end;
GetMem( CharSet, (Width+1)*(Height+1)*(MaxNumChars+1));
for k := 0 to MaxNumChars do
for i := 0 to Width do
for j := 0 to Height do
Charset^[k][i,j] := False;
PresentChar := 0;
GM.Initialize;
DrawChar( PresentChar );
for i := 0 to Width do
for j := 0 to Height do
Rectangle( i*9, j*9, i*9+9, j*9+9, 254);
Done := False;
CutX := (Width+1)*9;
CutY := (Height+1)*9;
end;
procedure FillSquare( A, B : integer; State : boolean );
var s, t, XShift, YShift, Color : integer;
begin
if State = True then Color := 253
else Color := 0;
s := trunc( xx / 9 );
t := trunc( yy / 9 );
GM. Show( False );
RectFill( s*9+1, t*9+1, s*9+8, t*9+8, Color );
XShift := (PresentChar mod 16)*39+12;
YShift := (PresentChar div 16)*39+252;
Plot( XShift+s, YShift+t, Color );
GM.Show( True );
CharSet^[PresentChar][s,t] := State;
end;
procedure SaveCharSet;
var i, j, k : integer;
fil : file of CharSetType;
begin
GM.Show( False );
assign( fil, CharSetName );
rewrite( fil );
write( fil, Charset^ );
Close( fil );
GM.Show( True );
end;
procedure LoadCharSet;
var i, j, k, XShift, YShift : integer;
fil : file of CharSetType;
Color : byte;
begin
GM.Show( False );
Rx := (PresentChar mod 16)*39+6;
Ry := (PresentChar div 16)*39+246;
Rectangle( Rx, Ry, Rx+27, Ry+27, 0 );
assign( fil,CharSetName );
reset( fil );
Read( fil, Charset^ );
Close( fil );
for k := 0 to MaxNumChars do
for i := 0 to Width do
for j := 0 to Height do
begin
XShift := (k mod 16)*39+12;
YShift := (k div 16)*39+252;
if CharSet^[k][i,j] then Color := 253
else Color := 0 ;
Plot( XShift+i, YShift+j, Color );
end;
PresentChar := 0;
GM.Show( True );
DrawChar( PresentChar );
end;
begin
SetUp;
repeat
GM.CheckMouse;
GM.GetPosition( Btn, xx, yy );
if ( Btn AND $01 = $01 ) AND ( xx < CutX ) AND ( yy < CutY ) then
FillSquare( xx, yy, True );
if ( Btn AND $02 = $02 ) AND ( xx < CutX ) AND ( yy < CutY ) then
FillSquare( xx, yy, False );
if ( Btn AND $01 = $01 ) AND ( yy > 240 ) then
begin
Rx := (PresentChar mod 16)*39+6;
Ry := (PresentChar div 16)*39+246;
Rectangle( Rx, Ry, Rx+27, Ry+27, 0 );
PresentChar := (xx div 39) + ((yy-240) div 39)*16;
DrawChar( PresentChar );
end;
if keypressed = True then
begin
ReadCh := ReadKey;
case ReadCh of
's','S' : SaveCharSet;
'l','L' : LoadCharSet;
'q','Q' : Done := True;
end;
end;
until Done;
ExitGraphics;
end.